home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / afpa.lisp < prev    next >
Encoding:
Text File  |  1992-03-10  |  15.5 KB  |  487 lines
  1. ;;; -*- Package: RT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: afpa.lisp,v 1.4 92/03/09 20:37:26 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; The following code is to support the AFPA on the EAPC card and the
  15. ;;; accessory AFPA for the APC card.  There isn't heavy use of AFPA features;
  16. ;;; other than the size of the register set, and the DMA use, this would work
  17. ;;; on the FPA (supposing anyone still has one of those.)  This is adapted from
  18. ;;; the 68881 support, and from the MIPS support.
  19. ;;;
  20. ;;; See section 4 in Vol 1 of the RT technical manual.  In particular DMA is
  21. ;;; described on 4-96 to 4-98.
  22. ;;;
  23. (in-package "RT")
  24.  
  25. ;;;; Status register formats.
  26.  
  27. (defconstant afpa-rounding-mode-byte (byte 2 (- 31 24)))
  28. (defconstant afpa-compare-result-byte (byte 2 (- 31 22)))
  29.  
  30. ;;; The condition code bits.
  31. ;;;
  32. (defconstant afpa-compare-gtr #b00)
  33. (defconstant afpa-compare-eql #b01)
  34. (defconstant afpa-compare-lss #b10)
  35. (defconstant afpa-compare-unordered #b11)
  36.  
  37. ;;; ### Note: the following status register constants are totally bogus (are
  38. ;;; actually for the mc68881, and exist only to make some code compile without
  39. ;;; errors.
  40. ;;;
  41. ;;; Encoding of float exceptions in the FLOATING-POINT-MODES result.  This is
  42. ;;; also the encoding used in the mc68881 accrued exceptions.
  43. ;;;
  44. (defconstant float-inexact-trap-bit (ash 1 0))
  45. (defconstant float-divide-by-zero-trap-bit (ash 1 1))
  46. (defconstant float-underflow-trap-bit (ash 1 2))
  47. (defconstant float-overflow-trap-bit (ash 1 3))
  48. (defconstant float-invalid-trap-bit (ash 1 4))
  49.  
  50. (defconstant float-round-to-nearest 0)
  51. (defconstant float-round-to-zero 1)
  52. (defconstant float-round-to-negative 2)
  53. (defconstant float-round-to-positive 3)
  54.  
  55. ;;; Positions of bits in the FLOATING-POINT-MODES result.
  56. ;;;
  57. (defconstant float-rounding-mode (byte 2 0))
  58. (defconstant float-sticky-bits (byte 5 2))
  59. (defconstant float-traps-byte (byte 5 7))
  60. (defconstant float-exceptions-byte (byte 5 12))
  61. (defconstant float-fast-bit 0)
  62.  
  63.  
  64. ;;;; Move functions:
  65. ;;;
  66. ;;;    Since moving between memory and a FP register reqires *two* temporaries,
  67. ;;; we need a special temporary to form the magic address we store to do a
  68. ;;; floating point operation.  We get this temp by always spilling NL0 on the
  69. ;;; number stack.  See WITH-FP-TEMP in the 68881 support.
  70. ;;;
  71. ;;; We also use LIP to form the address of the data location that we are
  72. ;;; reading or writing.
  73.  
  74.  
  75. (define-move-function (load-afpa-single 7) (vop x y)
  76.   ((single-stack) (afpa-single-reg))
  77.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
  78.   (with-fp-temp (temp)
  79.     (inst afpa-load y lip-tn :single temp)
  80.     (inst afpa-noop temp)))
  81.  
  82. (define-move-function (store-single 8) (vop x y)
  83.   ((afpa-single-reg) (single-stack))
  84.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  85.   (with-fp-temp (temp)
  86.     (inst afpa-store x lip-tn :single temp)
  87.     (inst afpa-noop temp)))
  88.  
  89. (define-move-function (load-double 7) (vop x y)
  90.   ((double-stack) (afpa-double-reg))
  91.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
  92.   (with-fp-temp (temp)
  93.     (inst afpa-load y lip-tn :double temp)
  94.     (inst afpa-noop temp)))
  95.  
  96. (define-move-function (store-double 8) (vop x y)
  97.   ((afpa-double-reg) (double-stack))
  98.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  99.   (with-fp-temp (temp)
  100.     (inst afpa-store x lip-tn :double temp)
  101.     (inst afpa-noop temp)))
  102.  
  103.  
  104. ;;;; Move VOPs:
  105.  
  106.  
  107. (macrolet ((frob (vop sc inst)
  108.          `(progn
  109.         (define-vop (,vop)
  110.           (:args (x :scs (,sc)
  111.                 :target y
  112.                 :load-if (not (location= x y))))
  113.           (:results (y :scs (,sc)
  114.                    :load-if (not (location= x y))))
  115.           (:note "float move")
  116.           (:temporary (:sc sap-reg) temp)
  117.           (:generator 0
  118.             (unless (location= y x)
  119.               (inst afpa-unop y x ,inst temp))))
  120.         (define-move-vop ,vop :move (,sc) (,sc)))))
  121.   (frob afpa-single-move afpa-single-reg :cops)
  122.   (frob afpa-double-move afpa-double-reg :copl))
  123.  
  124.  
  125.  
  126. (macrolet ((frob (name format data sc)
  127.          `(progn
  128.         (define-vop (,name)
  129.           (:args (x :scs (descriptor-reg)))
  130.           (:results (y :scs (,sc)))
  131.           (:temporary (:sc sap-reg) temp)
  132.           (:generator 7
  133.             (inst cal lip-tn x (- (* ,data vm:word-bytes)
  134.                       vm:other-pointer-type))
  135.             (inst afpa-load y lip-tn ,format temp)
  136.             (inst afpa-noop temp)))
  137.         (define-move-vop ,name :move (descriptor-reg) (,sc)))))
  138.   (frob move-to-afpa-single :single vm:single-float-value-slot
  139.     afpa-single-reg)
  140.   (frob move-to-afpa-double :double vm:double-float-value-slot
  141.     afpa-double-reg))
  142.  
  143.  
  144.  
  145. (macrolet ((frob (name sc format size type data)
  146.          `(progn
  147.         (define-vop (,name)
  148.           (:args (x :scs (afpa-single-reg afpa-double-reg) :to :save))
  149.           (:results (y :scs (descriptor-reg)))
  150.           (:temporary (:scs (sap-reg)) ndescr)
  151.           (:temporary (:scs (word-pointer-reg)) alloc)
  152.           (:generator 20
  153.             (with-fixed-allocation (y ndescr alloc ,type ,size)
  154.               (inst cal lip-tn y (- (* ,data vm:word-bytes)
  155.                         vm:other-pointer-type))
  156.               (inst afpa-store x lip-tn ,format ndescr)
  157.               (inst afpa-noop ndescr))))
  158.         (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  159.   (frob move-from-afpa-single afpa-single-reg
  160.     :single vm:single-float-size vm:single-float-type
  161.     vm:single-float-value-slot)
  162.   (frob move-from-afpa-double afpa-double-reg
  163.     :double vm:double-float-size vm:double-float-type
  164.     vm:double-float-value-slot))
  165.  
  166. (define-vop (move-to-afpa-argument)
  167.   (:args (x :scs (afpa-single-reg afpa-double-reg))
  168.      (nfp :scs (word-pointer-reg)
  169.           :load-if (not (sc-is y afpa-single-reg afpa-double-reg))))
  170.   (:results (y))
  171.   (:temporary (:sc sap-reg) temp)
  172.   (:variant-vars format)
  173.   (:vop-var vop)
  174.   (:generator 7
  175.     (sc-case y
  176.       ((afpa-single-reg afpa-double-reg)
  177.        (unless (location= y x)
  178.      (inst afpa-move y x format temp)))
  179.       ((single-stack double-stack)
  180.        (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  181.        (inst afpa-store y lip-tn format temp)
  182.        (inst afpa-noop temp)))))
  183.  
  184. (macrolet ((frob (name format sc)
  185.          `(progn
  186.         (define-vop (,name move-to-afpa-argument)
  187.           (:variant ,format))
  188.         (define-move-vop ,name :move-argument
  189.           (,sc descriptor-reg) (,sc)))))
  190.   (frob move-afpa-single-float-argument :single afpa-single-reg)
  191.   (frob move-afpa-double-float-argument :double afpa-double-reg))
  192.  
  193. (define-move-vop move-argument :move-argument
  194.   (afpa-single-reg afpa-double-reg) (descriptor-reg))
  195.  
  196.  
  197. ;;;; Arithmetic VOPs:
  198.  
  199. (define-vop (afpa-op)
  200.   (:args (x) (y))
  201.   (:results (r))
  202.   (:temporary (:sc sap-reg) temp)
  203.   (:policy :fast-safe)
  204.   (:guard (eq *target-float-hardware* :afpa))
  205.   (:note "inline float arithmetic")
  206.   (:vop-var vop)
  207.   (:save-p :compute-only))
  208.  
  209. (macrolet ((frob (name sc ptype format)
  210.          `(define-vop (,name afpa-op)
  211.         (:args (x :scs (,sc) :target r)
  212.                (y :scs (,sc)))
  213.         (:results (r :scs (,sc) :from (:argument 0)))
  214.         (:arg-types ,ptype ,ptype)
  215.         (:result-types ,ptype)
  216.         (:variant-vars op)
  217.         (:generator 20
  218.           (unless (location= x r)
  219.             (inst afpa-move r x ,format temp))
  220.           (note-this-location vop :internal-error)
  221.           (inst afpa-binop r y op temp)))))
  222.   (frob afpa-single-float-op afpa-single-reg afpa-single-float :single)
  223.   (frob afpa-double-float-op afpa-double-reg afpa-double-float :double))
  224.  
  225. (macrolet ((frob (op sinst sname dinst dname)
  226.          `(progn
  227.         (define-vop (,sname afpa-single-float-op)
  228.           (:translate ,op)
  229.           (:variant ,sinst))
  230.         (define-vop (,dname afpa-double-float-op)
  231.           (:translate ,op)
  232.           (:variant ,dinst)))))
  233.   (frob + :adds +/single-float :addl +/double-float)
  234.   (frob - :subs -/single-float :subl -/double-float)
  235.   (frob * :muls */single-float :mull */double-float)
  236.   (frob / :divs //single-float :divl //double-float))
  237.  
  238. (define-vop (afpa-unop afpa-op)
  239.   (:args (x)))
  240.  
  241. (macrolet ((frob (name sc ptype)
  242.          `(define-vop (,name afpa-unop)
  243.         (:args (x :scs (,sc)))
  244.         (:results (r :scs (,sc)))
  245.         (:arg-types ,ptype)
  246.         (:result-types ,ptype)
  247.         (:variant-vars op)
  248.         (:generator 20
  249.           (inst afpa-unop r x op temp)))))
  250.   (frob afpa-single-float-unop afpa-single-reg afpa-single-float)
  251.   (frob afpa-double-float-unop afpa-double-reg afpa-double-float))
  252.  
  253.  
  254. (macrolet ((frob (op sinst sname dinst dname)
  255.          `(progn
  256.         (define-vop (,sname afpa-single-float-unop)
  257.           (:translate ,op)
  258.           (:variant ,sinst))
  259.         (define-vop (,dname afpa-double-float-unop)
  260.           (:translate ,op)
  261.           (:variant ,dinst)))))
  262.   (frob abs :abss abs/single-float :absl abs/double-float)
  263.   (frob %negate :negs %negate/single-float :negl %negate/double-float))
  264.  
  265.  
  266. ;;;; Comparison:
  267.  
  268. (define-vop (afpa-compare)
  269.   (:args (x) (y))
  270.   (:conditional)
  271.   (:info target not-p)
  272.   (:policy :fast-safe)
  273.   (:guard (eq *target-float-hardware* :afpa))
  274.   (:temporary (:sc sap-reg) temp)
  275.   (:variant-vars condition format)
  276.   (:note "inline float comparison")
  277.   (:vop-var vop)
  278.   (:save-p :compute-only)
  279.   (:generator 15
  280.     (note-this-location vop :internal-error)
  281.     (inst afpa-compare x y
  282.       (ecase format
  283.         (:single :comts)
  284.         (:double :comtl))
  285.       temp)
  286.     (inst afpa-get-status temp temp)
  287.     (inst nilz temp temp (mask-field afpa-compare-result-byte -1))
  288.     (inst c temp (dpb condition afpa-compare-result-byte 0))
  289.     (if not-p
  290.     (inst bnc :eq target)
  291.     (inst bc :eq target))))
  292.  
  293.  
  294. (macrolet ((frob (name sc ptype)
  295.          `(define-vop (,name afpa-compare)
  296.         (:args (x :scs (,sc))
  297.                (y :scs (,sc)))
  298.         (:arg-types ,ptype ,ptype))))
  299.   (frob afpa-single-float-compare afpa-single-reg afpa-single-float)
  300.   (frob afpa-double-float-compare afpa-double-reg afpa-double-float))
  301.  
  302. (macrolet ((frob (translate sname dname condition)
  303.          `(progn
  304.         (define-vop (,sname afpa-single-float-compare)
  305.           (:translate ,translate)
  306.           (:variant ,condition :single))
  307.         (define-vop (,dname afpa-double-float-compare)
  308.           (:translate ,translate)
  309.           (:variant ,condition :double)))))
  310.   (frob < afpa-</single-float afpa-</double-float afpa-compare-lss)
  311.   (frob > afpa->/single-float afpa->/double-float afpa-compare-gtr)
  312.   (frob eql afpa-eql/single-float afpa-eql/double-float afpa-compare-eql))
  313.  
  314.  
  315. ;;;; Conversion:
  316.  
  317. (macrolet ((frob (name translate
  318.                from-sc from-type
  319.                to-sc to-type
  320.                word-p op)
  321.          `(define-vop (,name)
  322.         (:args (x :scs (,from-sc)))
  323.         (:results (y :scs (,to-sc)))
  324.         (:arg-types ,from-type)
  325.         (:result-types ,to-type)
  326.         (:temporary (:sc sap-reg) temp)
  327.         (:policy :fast-safe)
  328.         (:guard (eq *target-float-hardware* :afpa))
  329.         (:note "inline float coercion")
  330.         (:translate ,translate)
  331.         (:vop-var vop)
  332.         (:save-p :compute-only)
  333.         (:generator 10
  334.           (note-this-location vop :internal-error)
  335.           ,@(if word-p
  336.             `((inst afpa-put-float-inst y x temp
  337.                 (do-afpa-inst ,op temp :fr2 y :data x
  338.                           :ds :fr1-immediate)))
  339.             `((inst afpa-unop y x ,op temp)))))))
  340.   (frob %afpa-single-float/signed %single-float
  341.     signed-reg signed-num
  342.     afpa-single-reg afpa-single-float
  343.     t :cws)
  344.   (frob %afpa-double-float/signed %double-float
  345.     signed-reg signed-num
  346.     afpa-double-reg afpa-double-float
  347.     t :cwl)
  348.   (frob %afpa-single-float/double-float %single-float
  349.     afpa-double-reg afpa-double-float
  350.     afpa-single-reg afpa-single-float
  351.     nil :cls)
  352.   (frob %afpa-double-float/single-float %double-float
  353.     afpa-single-reg afpa-single-float
  354.     afpa-double-reg afpa-double-float
  355.     nil :csl))
  356.  
  357. (macrolet ((frob (translate name from-sc from-type op)
  358.          `(define-vop (,name)
  359.         (:args (x :scs (,from-sc)))
  360.         (:results (y :scs (signed-reg)))
  361.         (:temporary (:from (:argument 0) :sc ,from-sc) fp-temp)
  362.         (:temporary (:sc sap-reg) temp)
  363.         (:arg-types ,from-type)
  364.         (:result-types signed-num)
  365.         (:translate ,translate)
  366.         (:policy :fast-safe)
  367.         (:guard (eq *target-float-hardware* :afpa))
  368.         (:note "inline float round/truncate")
  369.         (:vop-var vop)
  370.         (:save-p :compute-only)
  371.         (:generator 10
  372.           (note-this-location vop :internal-error)
  373.           (inst afpa-unop fp-temp x ,op temp)
  374.           (inst afpa-get-float y fp-temp temp)))))
  375.  
  376.   (frob %unary-round %unary-round/afpa-single-float
  377.     afpa-single-reg afpa-single-float :rsw)
  378.   (frob %unary-round %unary-round/afpa-double-float
  379.     afpa-double-reg afpa-double-float :rlw)
  380.   (frob %unary-truncate %unary-truncate/afpa-single-float
  381.     afpa-single-reg afpa-single-float :tsw)
  382.   (frob %unary-truncate %unary-truncate/afpa-double-float
  383.     afpa-double-reg afpa-double-float :tlw))
  384.  
  385.  
  386. (define-vop (make-afpa-single-float)
  387.   (:args (bits :scs (signed-reg)))
  388.   (:results (res :scs (afpa-single-reg)))
  389.   (:arg-types signed-num)
  390.   (:temporary (:sc sap-reg) temp)
  391.   (:guard (eq *target-float-hardware* :afpa))
  392.   (:result-types afpa-single-float)
  393.   (:translate make-single-float)
  394.   (:policy :fast-safe)
  395.   (:generator 5
  396.     (inst afpa-put-float res bits temp)))
  397.  
  398. (define-vop (make-afpa-double-float)
  399.   (:args (hi-bits :scs (signed-reg))
  400.      (lo-bits :scs (unsigned-reg)))
  401.   (:results (res :scs (afpa-double-reg)))
  402.   (:temporary (:sc sap-reg) temp)
  403.   (:guard (eq *target-float-hardware* :afpa))
  404.   (:arg-types signed-num unsigned-num)
  405.   (:result-types afpa-double-float)
  406.   (:translate make-double-float)
  407.   (:policy :fast-safe)
  408.   (:generator 10
  409.     (inst afpa-put-float-odd res lo-bits temp)
  410.     (inst afpa-put-float res hi-bits temp)))
  411.  
  412. (define-vop (afpa-single-float-bits)
  413.   (:args (float :scs (afpa-single-reg)))
  414.   (:results (bits :scs (signed-reg)))
  415.   (:temporary (:sc sap-reg) temp)
  416.   (:guard (eq *target-float-hardware* :afpa))
  417.   (:arg-types afpa-single-float)
  418.   (:result-types signed-num)
  419.   (:translate single-float-bits)
  420.   (:policy :fast-safe)
  421.   (:generator 5
  422.     (inst afpa-get-float bits float temp)))
  423.  
  424. (define-vop (afpa-double-float-high-bits)
  425.   (:args (float :scs (afpa-double-reg)))
  426.   (:results (hi-bits :scs (signed-reg)))
  427.   (:temporary (:sc sap-reg) temp)
  428.   (:guard (eq *target-float-hardware* :afpa))
  429.   (:arg-types afpa-double-float)
  430.   (:result-types signed-num)
  431.   (:translate double-float-high-bits)
  432.   (:policy :fast-safe)
  433.   (:generator 5
  434.     (inst afpa-get-float hi-bits float temp)))
  435.  
  436. (define-vop (afpa-double-float-low-bits)
  437.   (:args (float :scs (afpa-double-reg)))
  438.   (:results (lo-bits :scs (unsigned-reg)))
  439.   (:temporary (:sc sap-reg) temp)
  440.   (:guard (eq *target-float-hardware* :afpa))
  441.   (:arg-types afpa-double-float)
  442.   (:result-types unsigned-num)
  443.   (:translate double-float-low-bits)
  444.   (:policy :fast-safe)
  445.   (:generator 5
  446.     (inst afpa-get-float-odd lo-bits float temp)))
  447.  
  448.  
  449. ;;;; Float mode hackery:
  450.  
  451. (deftype float-modes () '(unsigned-byte 32))
  452. (defknown floating-point-modes () float-modes (flushable))
  453. (defknown ((setf floating-point-modes)) (float-modes)
  454.   float-modes)
  455.  
  456. (define-vop (floating-point-modes)
  457.   (:results (res :scs (unsigned-reg)))
  458.   (:result-types unsigned-num)
  459.   (:translate floating-point-modes)
  460.   (:policy :fast-safe)
  461.   #+nil (:vop-var vop)
  462.   #+nil (:temporary (:sc unsigned-stack) temp)
  463.   (:generator 3
  464.     #+nil
  465.     (let ((nfp (current-nfp-tn vop)))
  466.       (inst stfsr nfp (* word-bytes (tn-offset temp)))
  467.       (loadw res nfp (tn-offset temp))
  468.       (inst nop))
  469.     (inst li res 0)))
  470.  
  471. (define-vop (set-floating-point-modes)
  472.   (:args (new :scs (unsigned-reg) :target res))
  473.   (:results (res :scs (unsigned-reg)))
  474.   (:arg-types unsigned-num)
  475.   (:result-types unsigned-num)
  476.   (:translate (setf floating-point-modes))
  477.   (:policy :fast-safe)
  478.   #+nil (:temporary (:sc unsigned-stack) temp)
  479.   #+nil (:vop-var vop)
  480.   (:generator 3
  481.     #+nil
  482.     (let ((nfp (current-nfp-tn vop)))
  483.       (storew new nfp (tn-offset temp))
  484.       (inst ldfsr nfp (* word-bytes (tn-offset temp)))
  485.       (move res new))
  486.     (move res new)))
  487.